COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00007 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct node-record
 (count 0)
 (name nil)
 (qlink nil)
 (top nil))

(defmacro unless (x . y) `(cond ((not ,x) ,@y)))

(defmacro when (x . y) `(cond (,x ,@y)))

(defmacro incf (loc) `(setf ,loc (plus ,loc 1)))

(defmacro decf (loc) `(setf ,loc (plus ,loc -1)))

(defmacro node-record (node) `(cadr ,node))

(defmacro loop forms `(do () (()) ,@forms))

(defmacro dolist ((stepper starter) .forms)
 (let ((var (gensym)))
 `(do ((,var ,starter (cdr ,var))
       (,stepper nil))
      ((null ,var))
   (setq ,stepper (car ,var))
   ,@forms)))

(declare (special *node-alist*) (special *n*))

(defmacro node-record-exists (node) `(assq ,node *node-alist*))

(defmacro find-node-record (node) `(cadr (assq ,node *node-alist*)))

(defun init () (setq *node-alist* nil) (setq *n* 0))

(defmacro defclass (class superclasses ignore)
  (unless (node-record-exists class)
	  (incf *n*)
	  (push `(,class ,(make-node-record name class)) *node-alist*))
  (do ((sc superclasses (cdr sc)))
      ((null sc))
   (let ((class1 (car sc))
	 (class2 (cadr sc)))
    (unless (node-record-exists class1)
	    (incf *n*)
	    (push 
	     `(,class1 ,(make-node-record name class1)) *node-alist*))
    (when class2
	  (unless (node-record-exists class2)
		  (incf *n*)
		  (push 
		   `(,class2 ,(make-node-record name class2))
		   *node-alist*))
	   (record-relation class1 class2))
    (record-relation class class1)))
  `(quote ,class))

;;; Records that node1<node2
;;;
(defun record-relation (node1 node2)
 (let ((node1-record (find-node-record node1))
       (node2-record (find-node-record node2)))
  (incf (count node2-record))
  (setf (top node1-record) (cons node2-record (top node1-record)))
  node1))

(defun topologically-sort ()
 (let* ((front nil)
	(cpl nil)
	(unique-total-order t)
	(none (ncons ()))
	(dummy-node (make-node-record name none qlink none))
	(rear dummy-node))
  ;; Link together the nodes with count=0 (no predecessors)
  (dolist (node *node-alist*)
   (setf (qlink (node-record node)) none)
   (when (zerop (count (node-record node)))
	 (setf (qlink rear) (node-record node))
	 (setq rear (node-record node))))
  (setq front (qlink dummy-node))
  ;; Do the sort
  (loop
   (when (eq front none) 
	 (cond ((zerop *n*) (return cpl))
	       (t (error '|Inconsistent Lattice|)
		  (return nil))))
   (push (name front) cpl)
   ;; Could a different 0-count node be output next?
   (unless (eq front rear) (setq unique-total-order nil))
   (decf *n*)
   ;; Recalculate the counts and queue of 0-count nodes
   (dolist (p (top front))
    (when (zerop (decf (count p)))
	  (setf (qlink rear) p)
	  (setq rear p)))
   (setq front (qlink front)))
  ;; See if a choice was ever possible
  (unless unique-total-order 
	  (princ "Multiple Total Orders Possible")
	  (terpri))
  (reverse cpl)))